home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 9 / Night Owl CD-ROM (NOPV9) (Night Owl Publisher) (1993).ISO / 012a / lib194.zip / PROC.PRG < prev    next >
Text File  |  1993-02-12  |  88KB  |  2,193 lines
  1. *-- PROGRAM.....: PROC.PRG 
  2. *-------------------------------------------------------------------------------
  3. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  4. *-- Date........: 11/10/1992
  5. *-- Version.....: 2.92 -- See WHATS.NEW and README.TXT files (both ASCII),
  6. *--               both files uploaded with this file in one
  7. *--               zipped file.
  8. *-- Notes.......: This procedure file is part of the new and improved set of
  9. *--               files, re-designed for dBASE IV, 1.5. The complete set is
  10. *--               contained in the file: LIB192.ZIP. Please read README.TXT
  11. *--               for all instructions.
  12. *===============================================================================
  13.  
  14. *===============================================================================
  15. * MESSAGE/SCREEN PROCESSING ROUTINES -- includes message boxes, shadowing,
  16. * and centering of text ... Anything not here is in the library file: 
  17. * SCREEN.PRG.
  18. *===============================================================================
  19.  
  20. PROCEDURE PrintErr
  21. *-------------------------------------------------------------------------------
  22. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  23. *-- Date........: 05/24/1991
  24. *-- Notes.......: Used to display a printer error for STAND-ALONE
  25. *--               systems. (The dBASE function PRINTSTATUS() doesn't work
  26. *--               well on a Network with Print Spoolers ...)
  27. *-- Written for.: dBASE IV, 1.1
  28. *-- Rev. History: None
  29. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  30. *--               CENTER               Procedure in PROC.PRG
  31. *-- Called by...: Any
  32. *-- Usage.......: do printerr
  33. *-- Example.....: do setprint  && if it hasn't been done
  34. *--               if .not. printstatus()
  35. *--                  DO PRINTERR
  36. *--               endif
  37. *--               *    or
  38. *--               do while .not. printstatus() && my preference ... loop!
  39. *--                  DO PRINTERR
  40. *--               enddo
  41. *-- Returns.....: None
  42. *-- Parameters..: None
  43. *-------------------------------------------------------------------------------
  44.  
  45.     private cColor, cDummy, cCursor
  46.     
  47.     if iscolor()    && if we're using a color monitor, use yellow on red
  48.         cColor = "RG+/R,RG+/R,RG+/R"
  49.     else            && otherwise, use black on white
  50.         cColor = "N/W,N/W,N/W"
  51.     endif
  52.     
  53.     activate screen
  54.     define window wPErr from  7,15 to 16,57 double color &cColor
  55.     save screen to sPErr       && store current screen
  56.     do shadow with 7,15,16,57    && shadow box!
  57.     activate window wPErr      && here we go ..
  58.     
  59.     cCursor=set("CURSOR")      && save cursor setting
  60.     set cursor off             && turn cursor off
  61.                                && display message
  62.     do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***"
  63.     do center with 2,40,""," The printer is not ready. Please check:"
  64.     do center with 3,40,"","1) that the printer is ON,        "
  65.     do center with 4,40,"","2) that the printer is ONLINE, and"
  66.     do center with 5,40,"","3) that the printer has paper.    "
  67.     do center with 7,40,"","Press any key to continue . . ."
  68.     
  69.     cDummy=inkey(0)            && wait for user to press a key ...
  70.     set cursor &cCursor        && set cursor to original setting ...
  71.     
  72.     deactivate window wPErr    && cleanup
  73.     release window wPErr
  74.     restore screen from sPErr
  75.     release screen sPErr
  76.     
  77. RETURN  
  78. *-- EoP: PrintErr
  79.  
  80. PROCEDURE Open_Screen
  81. *-------------------------------------------------------------------------------
  82. *-- Programmer..: Rick Price (HAMMETT)
  83. *-- Date........: 05/24/1991
  84. *-- Notes.......: Used to give a texture to the background of the screen
  85. *--               I got this from Rick when he uploaded it as part of his 
  86. *--               original entry to a Color Contest on the ATBBS. It is
  87. *--               kinda nice to have that texture on the screen, keeps it
  88. *--               from being monotonous.
  89. *-- Written for.: dBASE IV, 1.1
  90. *-- Rev. History: None
  91. *-- Calls.......: None
  92. *-- Called by...: Any
  93. *-- Usage.......: do open_screen
  94. *-- Example.....: do open_screen
  95. *-- Returns.....: None
  96. *-- Parameters..: None
  97. *-------------------------------------------------------------------------------
  98.  
  99.     private nRow, cBackDrp, nHoldRow
  100.     
  101.     clear
  102.     nRow=0
  103.     cBackdrp = chr(176)  && chr(176) = "░", chr(177) = "▒", chr(178) = "▓"
  104.     do while nRow < 3
  105.        @nRow,0 to nRow+3,79 cBackdrp  && fill this section of the screen
  106.        nHoldRow = nRow
  107.        nRow = nRow + 6
  108.        @nRow,0 to nRow+3,79 cBackdrp
  109.        nRow = nRow + 6
  110.        @nRow,0 to nRow+3,79 cBackdrp
  111.        nRow = nRow + 6
  112.        @nRow,0 to nRow+3,79 cBackdrp
  113.        nRow = nHoldRow + 1
  114.     enddo
  115.     @24,0 to 24,79 cBackdrp
  116.  
  117. RETURN
  118. *-- EoP: OpenScreen
  119.  
  120. PROCEDURE JazClear
  121. *-------------------------------------------------------------------------------
  122. *-- Programmer..: Rick Price (HAMMETT)
  123. *-- Date........: 05/24/1991
  124. *-- Notes.......: Used to clear the screen from the middle out --
  125. *--               could be used with OpenScreen, above. I got this
  126. *--               from Rick at the same time I got the other routine above ...
  127. *--               This requires a full screen (0,0 to 23,79 ...)
  128. *-- Written for.: dBASE IV, 1.1
  129. *-- Rev. History: None
  130. *-- Calls.......: None
  131. *-- Called by...: Any
  132. *-- Usage.......: do jazclear
  133. *-- Examples....: do jazclear
  134. *-- Returns.....: None
  135. *-- Parameters..: None
  136. *-------------------------------------------------------------------------------
  137.  
  138.     private nWinR1, nWinR2, nWinC1, nWinC2, nStep, mnWinC1, mnWinC2, ;
  139.             mnWinR1, mnWinR2, nStep, nTmpAdjR, nTmpAdjC, nAdjRow, nAdjCol
  140.     private nColLeft, nColRite, nRowTop, nRowBot
  141.     
  142.     nWinR1 = 0     && row 1
  143.     nWinR2 = 24  && row 2
  144.     nWinC1 = 0   && column 1
  145.     nWinC2 = 79  && column 2
  146.     nStep = 1    && amount to increment by
  147.       * set starting point
  148.     mnWinC1 = int((nWinC2-nWinC1)/2)+nWinC1
  149.     mnWinC2 = mnWinC1+1
  150.     mnWinR1 = int((nWinR2-nWinR1)/2)+nWinR1
  151.     mnWinR2 = mnWinR1+1
  152.     
  153.     ** Adjust step offset values: nColOff & nRowOff
  154.     ** Vertical steps: nWinR1-nWinR1
  155.     nTmpAdjR = int((nWinR2 - nWinR1)/2)
  156.     nTmpAdjC = int((nWinC2 - nWinC1)/2)
  157.     
  158.     nAdjRow = ;
  159.     iif(nTmpAdjC > nTmpAdjR, nTmpAdjR/nTmpAdjC,1) * nStep
  160.     
  161.     nAdjCol = ;
  162.     iif(nTmpAdjR > nTmpAdjC, nTmpAdjC/nTmpAdjR,1) * nStep
  163.     
  164.     ncolleft = nWinC1
  165.     ncolrite = nWinC2
  166.     nRowTop = nWinR1
  167.     nRowBot = nWinR2
  168.     nWinC1 = mnWinC1
  169.     nWinC2 = mnWinC2
  170.     nWinR1 = mnWinR1
  171.     nWinR2 = mnWinR2
  172.     do while (nWinC1#nColLeft .or. nWinC2#nColRite .or. ;
  173.         nWinR1 # nRowTop .or. nWinR2 # nRowBot)
  174.         
  175.         * Adjust coordinates for the clear (moving out from the middle)
  176.         nWinR1 = ;
  177.         nWinR1-iif(nRowTop<nWinR1-nAdjRow,nAdjRow,nWinR1-nRowTop)
  178.         nWinR2 = ;
  179.         nWinR2+iif(nRowBot>nWinR2+nAdjRow,nAdjRow,nRowBot-nWinR2)
  180.         nWinC1 = ;
  181.         nWinC1-iif(nColLeft<nWinC1-nAdjCol,nAdjCol,nWinC1-nColLeft)
  182.         nWinC2 = ;
  183.         nWinC2+iif(nColRite>nWinC2+nAdjCol,nAdjCol,nColRite-nWinC2)
  184.         
  185.         * Perform the clear
  186.         @nWinR1,nWinC1 clear to nWinR2,nWinC2
  187.         @nWinR1,nWinC1 to nWinR2,nWinC2
  188.     enddo
  189.     clear
  190.     
  191. RETURN   
  192. *-- EoP: JazClear
  193.  
  194. PROCEDURE Wipe
  195. *-------------------------------------------------------------------------------
  196. *-- Programmer..: Alan D. Frazier (CALLAE)
  197. *-- Date........: 01/10/1992
  198. *-- Notes.......: Used to wipe a window from left to right. Nice effect.
  199. *--               Parameters are the coordinates of the window ...
  200. *-- Written for.: dBASE IV, 1.1
  201. *-- Rev. History: None
  202. *-- Calls.......: None
  203. *-- Called by...: Any
  204. *-- Usage.......: do Wipe with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  205. *-- Example.....: define window test from 5,10 to 20,70
  206. *--               activate window test
  207. *--                   *-- do stuff in window
  208. *--               do Wipe with 5,10,20,70
  209. *-- Returns.....: None
  210. *-- Parameters..: nULRow = Upper (Left) Row
  211. *--               nULCol = (Upper) Left Column
  212. *--               nBRRow = Bottom (Right) Row
  213. *--               nBRCol = (Bottom) Right Column
  214. *-------------------------------------------------------------------------------
  215.  
  216.     parameter nULRow,nULCol,nBRRow,nBRCol
  217.  
  218.     private nULRow,nULCol,nBRRow,nBRCol,nCurLeft
  219.  
  220.     nCurLeft = 0    && always start at column 0 within the window
  221.     nBRRow  = nBRRow - nULRow - 2
  222.     nBRCol =  nBRCol - nULCol - 2
  223.  
  224.     do while nCurLeft+2 < nBRCol
  225.         @ 0,nCurLeft clear to nBRRow,nCurLeft + 2
  226.         nCurLeft = nCurLeft  + 2
  227.    enddo
  228.  
  229.    @ 0,nBRCol-2 CLEAR TO nBRRow,nBRCol - 1
  230.  
  231. RETURN
  232. *-- EoP: Wipe
  233.  
  234. PROCEDURE Center
  235. *-------------------------------------------------------------------------------
  236. *-- Programmer..: Miriam Liskin
  237. *-- Date........: 05/24/1991
  238. *-- Notes.......: Centers text on the screen with @says
  239. *-- Written for.: dBASE IV, 1.1
  240. *-- Rev. History: This and all other procedures/functions listed in this
  241. *--               file attributed to Miriam Liskin came from "Liskin's
  242. *--               Programming dBASE IV Book". Very good, worth the money.
  243. *-- Calls.......: None
  244. *-- Called by...: Any
  245. *-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
  246. *-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
  247. *--                  Note that the color field may be blank: ""
  248. *-- Returns.....: None
  249. *-- Parameters..: nLine  = Line or Row for @/Say
  250. *--               nWidth = Width of screen
  251. *--               cColor = Colors to be used ("Forg/Back") (may be nul "", in
  252. *--                           order to use the default colors of window/screen)
  253. *--               cText  = Message to center on screen
  254. *-------------------------------------------------------------------------------
  255.     
  256.     parameters nLine,nWidth,cColor,cText
  257.     private nCol
  258.     
  259.     nCol = (nWidth - len(cText)) /2
  260.     @nLine,nCol say cText color &cColor.
  261.     
  262. RETURN
  263. *-- EoP: Center
  264.  
  265. FUNCTION Surround
  266. *-------------------------------------------------------------------------------
  267. *-- Programmer..: Miriam Liskin
  268. *-- Date........: 05/24/1991
  269. *-- Notes.......: Displays a message surrounded by a box anywhere on 
  270. *--               the screen
  271. *-- Written for.: dBASE IV, 1.1
  272. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (CIS: 71333,1030) to a 
  273. *--               function from original procedure
  274. *-- Calls.......: None
  275. *-- Called by...: Any
  276. *-- Usage.......: surround(<nLine>,<nColumn>,"<cColor>","<cText>")
  277. *-- Example.....: cDummy = surround(5,12,"RG+/GB",;
  278. *--                        "Processing ... Do not Touch!")
  279. *-- Returns.....: Nul/""
  280. *-- Parameters..: nLine   = Line to display "surrounded" message at
  281. *--               nColumn = Column for same (X,Y coordinates for @SAY)
  282. *--               cColor  = Color variable/colors
  283. *--               cText   = Text to be displayed inside box
  284. *-------------------------------------------------------------------------------
  285.     
  286.     parameters nLine,nColumn,cColor,cText
  287.     
  288.     cText = " " + trim(cText) + " "             && add spaces around text
  289.     @nLine-1,nColumn-1 to nLine+1,nColumn+len(cText) double;
  290.         color &cColor.                           && draw box
  291.     @nLine,nColumn say cText color &cColor.  && disp. text
  292.     
  293. RETURN "" 
  294. *-- EoF: Surround()
  295.  
  296. FUNCTION Message1
  297. *-------------------------------------------------------------------------------
  298. *-- Programmer..: Miriam Liskin
  299. *-- Date........: 05/24/1991
  300. *-- Notes.......: Displays a message, centered at whatever line you give,
  301. *--               pauses until user presses a key.
  302. *-- Written for.: dBASE IV, 1.1
  303. *-- Rev. History: 04/19/1991 Modified by Ken Mayer from Miriam's 
  304. *--                procedure to function
  305. *-- Calls.......: CENTER               Procedure in PROC.PRG
  306. *-- Called by...: Any
  307. *-- Usage.......: message1(<nLine>,<nWidth>,"<cColor>","<cText>")
  308. *-- Example.....: cDummy = Message1(5,12,"RG+/GB","All Done.")
  309. *-- Returns.....: numeric value of key pressed by user (cUser)
  310. *-- Parameters..: nLine  = Line to display message
  311. *--               nWidth = Width of screen
  312. *--               cColor = Colors for display
  313. *--               cText  = Text to be displayed.
  314. *-------------------------------------------------------------------------------
  315.  
  316.     parameters nLine,nWidth,cColor,cText
  317.     private cCursor, cUser
  318.     
  319.     @nLine,0
  320.     cCursor = set("CURSOR")  && store current state of CURSOR
  321.     set cursor off           && turn it off
  322.     do center with nLine,nWidth,cColor,cText
  323.     cUser = inkey(0)
  324.     set cursor &cCursor      && set cursor to original state
  325.     @nLine,0                 && erase line ...
  326.  
  327. RETURN cUser
  328. *-- EoF: Message1()
  329.  
  330. FUNCTION Message2
  331. *-------------------------------------------------------------------------------
  332. *-- Programmer..: Miriam Liskin
  333. *-- Date........: 06/08/1992
  334. *-- Notes.......: Displays a message in a window, pauses for user to 
  335. *--               press key
  336. *-- Written for.: dBASE IV, 1.1
  337. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to a function
  338. *--               04/29/1991 - Modified by Ken Mayer to add shadow
  339. *--               06/08/1992 - Modified by same, to do EXPLICIT setting of
  340. *--               colors for window used.
  341. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  342. *--               CENTER               Procedure in PROC.PRG
  343. *-- Called by...: Any
  344. *-- Usage.......: message2("<cText>","<cColor>")
  345. *-- Example.....: cDummy = message2("Finished Processing!",;
  346. *--                         "RG+/GB,,RG+/GB")
  347. *-- Returns.....: numeric value of key pressed by user (cUser)
  348. *-- Parameters..: cText  = Text to be displayed in window
  349. *--               cColor = Colors for window
  350. *-------------------------------------------------------------------------------
  351.  
  352.     parameters cText,cColor
  353.     private cCursor, cUser
  354.     
  355.     cCursor = set("CURSOR")
  356.     set cursor off
  357.     save screen to sMessage
  358.     
  359.     *-- NOW we see what happens ...
  360.     activate screen
  361.     define window wMessage from 10,10 to 14,70 double color &cColor
  362.     do shadow with 10,10,14,70
  363.     activate window wMessage
  364.     
  365.     do center with 1,60,"",cText
  366.     wait "" to cUser
  367.     
  368.     *-- cleanup
  369.     set cursor &cCursor
  370.     
  371.     *-- remove window ...
  372.     deactivate window wMessage
  373.     release window wMessage
  374.     restore screen from sMessage
  375.     release screen sMessage
  376.  
  377. RETURN cUser
  378. *-- EoF: Message2()
  379.  
  380. FUNCTION Message3
  381. *-------------------------------------------------------------------------------
  382. *-- Programmer..: Miriam Liskin
  383. *-- Date........: 06/08/1992
  384. *-- Notes.......: Displays a message in a window, pauses for user, 
  385. *--               will wrap a long message inside the window.
  386. *-- Written for.: dBASE IV, 1.1
  387. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to a function
  388. *--               04/29/1991 - Modified to Ken Mayer add shadow
  389. *--               06/08/1992 - Modified to explicitly set the colors ...
  390. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  391. *-- Called by...: Any
  392. *-- Usage.......: Message3("<cText>","<cColor>")
  393. *-- Example.....: cDummy = Message3("This is a long message that will be"+;
  394. *--                 "wrapped around inside the window.","rg+/gb,,rg+/gb")
  395. *-- Returns.....: numeric value of key used to exit window (cUser)
  396. *-- Parameters..: cText  = Text to be displayed
  397. *--               cColor = Colors for window
  398. *-------------------------------------------------------------------------------
  399.  
  400.     parameters cText,cColor
  401.     private nLines,cCursor,cUser,nLMargin,nRMargin,cAlignment,lWrap
  402.     
  403.     nLines = int(len(cText) / 38) + 5    && set # of lines for window
  404.     
  405.     cCursor = set("CURSOR")
  406.     set cursor off
  407.     save screen to sMessage
  408.     
  409.     *-- define/activate window
  410.     activate screen
  411.     define window wMessage from 8,20 to 8+nLines,60 double color &cColor
  412.     do shadow with 8,20,8+nLines,60
  413.     activate window wMessage
  414.     
  415.     nLmargin   = _lmargin
  416.     nRmargin   = _rmargin
  417.     cAlignment = _alignment
  418.     lWrap      = _wrap
  419.     
  420.     _lmargin   = 1 
  421.     _rmargin   = 38
  422.     _alignment = "CENTER"
  423.     _wrap      = .t.
  424.     
  425.     ?cText
  426.     ?
  427.     wait "    Press any key to continue . . ." to cUser
  428.     
  429.     _lmargin   = nLmargin
  430.     _rmargin   = nRmargin
  431.     _alignment = cAlignment
  432.     _wrap      = lWrap
  433.     
  434.     set cursor &cCursor
  435.     deactivate window wMessage
  436.     release window wMessage
  437.     restore screen from sMessage
  438.     release screen sMessage
  439.  
  440. RETURN cUser
  441. *-- EoF: Message3()
  442.  
  443. FUNCTION Message4
  444. *-------------------------------------------------------------------------------
  445. *-- Programmer..: Miriam Liskin
  446. *-- Date........: 06/08/1992
  447. *-- Notes.......: Displays a 2-line message in a predefined window 
  448. *--                 and pauses
  449. *-- Written for.: dBASE IV, 1.1
  450. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to a function
  451. *--               04/29/1991 - Modified to Ken Mayer add shadow
  452. *--               06/08/1992 -- Modified to explicitly deal with colors
  453. *--               11/09/1992 - Modified by Joey Carroll to deal with text
  454. *--                parameters being too long.
  455. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  456. *--               CENTER               Procedure in PROC.PRG
  457. *-- Called by...: Any
  458. *-- Usage.......: message4("<cText1>","<cText2>","<cColor>")
  459. *-- Example.....: cDummy = message4("Finished processing.","There are ";
  460. *--                        +ltrim(str(reccount()))+" Records in this file.",;
  461. *--                        "rg+/rg,rg+/rg,rg+/rg")
  462. *-- Returns.....: numeric value of key pressed by user to exit window (cUser)
  463. *-- Parameters..: cText1 = First line of message
  464. *--               cText2 = Second line of message
  465. *--               cColor = Colors for window
  466. *-------------------------------------------------------------------------------
  467.  
  468.     parameters cText1,cText2,cColor
  469.     private cCursor,cUser,nLMargin,nRMargin,lWrap
  470.     
  471.     *-- if text params are too long, cut 'em off
  472.     cText1 = left(cText1,58)
  473.     cText2 = left(cText2,58)
  474.     
  475.     cCursor = set("CURSOR")
  476.     set cursor off
  477.     save screen to sMessage
  478.     
  479.     activate screen
  480.     define window wMonitor from 10,10 to 17,70 double color &cColor
  481.     do shadow with 10,10,17,70
  482.     activate window wMonitor
  483.     
  484.     nLmargin = _lmargin
  485.     nRmargin = _rmargin
  486.     lWrap =    _wrap
  487.     _lmargin = 1 
  488.     _rmargin = 58
  489.     _wrap    = .t.
  490.     
  491.     do center with 1,58,"",cText1
  492.     do center with 2,58,"",cText2
  493.     do center with 4,58,"","Press any key to continue . . ."
  494.     wait "" to cUser
  495.  
  496.     _lmargin = nLmargin
  497.     _rmargin = nRmargin
  498.     _wrap    = lWrap
  499.     set cursor &cCursor
  500.     deactivate window wMonitor
  501.     release window wMonitor
  502.     restore screen from sMessage
  503.     release screen sMessage
  504.     
  505. RETURN cUser
  506. *-- EoF: Message4()
  507.  
  508. FUNCTION ScrnHead
  509. *-------------------------------------------------------------------------------
  510. *-- Programmer..: Miriam Liskin
  511. *-- Date........: 05/23/1991
  512. *-- Notes.......: Displays a heading on the screen in a box 2 
  513. *--               spaces wider than the text, with a custom border (double 
  514. *--               line top, single the rest)
  515. *-- Written for.: dBASE IV, 1.1
  516. *-- Rev. History: 4/29/1991 - Modified by Ken Mayer to add shadow
  517. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  518. *-- Called by...: Any
  519. *-- Usage.......: scrnhead("<cColor>","<cText>")
  520. *-- Examples....: cDummy = ScrnHead("rg+/gb","Print Financial Report")
  521. *-- Returns.....: nul/""
  522. *-- Parameters..: cColor = Colors to display box/text in
  523. *--               cText  = text to be displayed.
  524. *-------------------------------------------------------------------------------
  525.  
  526.     parameters cColor,cText
  527.     private cTextStart,cText2
  528.     
  529.     cText2 = " "+trim(cText)+" "             && ad spaces to left and right
  530.     cTextstart = (80-len(trim(cText2)))/2
  531.     activate screen
  532.     do shadow with 1,cTextstart-1,3,81-cTextstart
  533.     @1,cTextstart-1 to 3,81-cTextstart 205,196,179,179,213,184,192,217;
  534.         color &cColor.                           && display box
  535.     @2, cTextstart say cText2 color &cColor. && display text
  536.  
  537. RETURN ""
  538. *-- EoF: ScrnHead()
  539.  
  540. FUNCTION YesNo
  541. *-------------------------------------------------------------------------------
  542. *-- Programmer..: Miriam Liskin
  543. *-- Date........: 06/08/1992
  544. *-- Notes.......: Asks a yes/no question in a dialog window/box
  545. *-- Written for.: dBASE IV, 1.1
  546. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  547. *--               04/29/1991 - Modified by Ken Mayer add shadow
  548. *--               05/13/1991 - Modified by Ken Mayer remove need for extra 
  549. *--                            procedures (YES/NO) that were used for returning
  550. *--                            values from Menu
  551. *--                            (suggested by Clinton L. Warren (VBCES))
  552. *--               01/20/1992 - Modified by Martin Leon (HMan) to handle user
  553. *--                            pressing 'Y' or 'N' keys (with ON KEY ...).
  554. *--               04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
  555. *--                            as occaisional problems appear otherwise.
  556. *--               06/08/1992 - Modified (Ken Mayer) to deal with explicit
  557. *--                            color processing.
  558. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  559. *--               CENTER               Procedure in PROC.PRG
  560. *-- Called by...: Any
  561. *-- Usage.......: yesno(<lAnswer>,"<cMess1>","<cMess2>","<cMess3>","<cColor>")
  562. *-- Example.....: if YesNo(.t.,"Do You Really Wish To Delete?",;
  563. *--                            "This will destroy the data";
  564. *--                             "in this record.";
  565. *--                             "rg+/gb,n/w,rg+/gb")
  566. *--                  delete
  567. *--               else
  568. *--                  skip
  569. *--               endif
  570. *--
  571. *--                 The middle set of colors should be different, as they
  572. *--                 will be the colors of the YES/NO selections ...
  573. *--                 Options may be blank by using nul values ("")
  574. *-- Returns.....: .t./.f. depending on user's choice from menu
  575. *-- Parameters..: lAnswer = default value (Yes or No) for menu
  576. *--               cMess1  =  First line of Message
  577. *--               cMess2  =  Second line of message
  578. *--               cMess3  =  Third line of message
  579. *--               cColor  =  Colors for window/menu/box
  580. *-------------------------------------------------------------------------------
  581.  
  582.     parameter lAnswer,cMess1,cMess2,cMess3,cColor
  583.     private nLMargin,nRMargin,lWrap
  584.     
  585.     save screen to sYesno
  586.     activate screen
  587.     define window wYesno from 8,20 to 15,60 double color &cColor
  588.     
  589.     define menu mYesno
  590.     *-- remove && from MESSAGE option if using or might be used on Mono system
  591.     define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
  592.     define pad pNo  of mYesno Prompt "[No]"  at 5,25 && message "No"
  593.     on selection pad pYes of mYesno deactivate menu
  594.     on selection pad pNo  of mYesno deactivate menu
  595.     
  596.     do shadow with 8,20,15,60
  597.     activate window wYesno
  598.     nLmargin = _lmargin    && store system values
  599.     nRmargin = _rmargin
  600.     lWrap    = _wrap
  601.     _lmargin   = 2            && set local values
  602.     _rmargin   = 38
  603.     _wrap      = .t.
  604.     
  605.     do center with 0,38,"",cMess1        && center the text
  606.     do center with 2,38,"",cMess2
  607.     do center with 3,38,"",cMess3
  608.  
  609.     *-- deal with user pressing 'Y' or 'N' ...
  610.    on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
  611.    on key label N keyboard IIF( PAD() = "PNO",  "", CHR(4)  )+chr(13)
  612.     *-- otherwise deal with regular "menu" abilities
  613.     clear typeahead
  614.    if lAnswer
  615.         activate menu mYesno pad pYes
  616.     else
  617.         activate menu mYesno pad pNo
  618.     endif
  619.     
  620.     *-- clear out ON KEY settings ...
  621.    on key label Y
  622.    on key label N
  623.     _lmargin = nLmargin    && reset system values
  624.     _rmargin = nRmargin
  625.     _wrap    = lWrap
  626.     deactivate window wYesno
  627.     release window wYesno
  628.     restore screen from sYesno
  629.     release screen sYesno
  630.     release menu mYesno
  631.  
  632. RETURN iif(pad()="PYES",.t.,.f.)
  633. *-- EoF: YesNo()
  634.  
  635. FUNCTION YesNo2
  636. *-------------------------------------------------------------------------------
  637. *-- Programmer..: Miriam Liskin
  638. *-- Date........: 06/08/1992
  639. *-- Notes.......: Asks a yes/no question in a dialog window/box
  640. *-- Written for.: dBASE IV, 1.1
  641. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  642. *--               04/29/1991 - Modified by Ken Mayer add shadow
  643. *--               05/13/1991 - Modified by Ken Mayer remove need for extra 
  644. *--                            procedures (YES/NO) that were used for returning
  645. *--                            values from Menu
  646. *--                            (suggested by Clinton L. Warren (VBCES))
  647. *--               11/15/1991 - Copied YesNo, modified to allow "location" 
  648. *--                            options -- useful for some screens ...
  649. *--               01/20/1992 - Modified by Martin Leon (HMAN) to allow user to
  650. *--                            press 'Y' or 'N' and have them recognized ...
  651. *--               04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
  652. *--                            as occaisional problems appear otherwise.
  653. *--               06/08/1992 - Modified by same for explicit color sets.
  654. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  655. *--               CENTER               Procedure in PROC.PRG
  656. *-- Called by...: Any
  657. *-- Usage.......: yesno2(<lAnswer>,"<cWhere>",;
  658. *--                                "<cMess1>","<cMess2>","<cMess3>","<cColor>")
  659. *-- Example.....: if YesNo2(.t.,"UL","Do You Really Wish To Delete?",;
  660. *--                            "This will destroy the data";
  661. *--                             "in this record.";
  662. *--                             "rg+/gb,n/w,rg+/gb")
  663. *--                  delete
  664. *--               else
  665. *--                  skip
  666. *--               endif
  667. *--
  668. *--                 The middle set of colors should be different, as they
  669. *--                 will be the colors of the YES/NO selections ...
  670. *--                 Options may be blank by using nul values ("")
  671. *-- Returns.....: .t./.f. depending on user's choice from menu
  672. *-- Parameters..: lAnswer = default value (Yes or No) for menu
  673. *--               cWhere  = location on screen:
  674. *--                            "UL" = Upper Left
  675. *--                            "UC" = Upper Center
  676. *--                            "UR" = Upper Right
  677. *--                            "CL" = Center Left
  678. *--                            "CC" = Center Center
  679. *--                            "CR" = Center Right
  680. *--                            "BL" = Bottom Left
  681. *--                            "BC" = Bottom Center
  682. *--                            "BR" = Bottom Right
  683. *--               cMess1  =  First line of Message
  684. *--               cMess2  =  Second line of message (may be nul = "")
  685. *--               cMess3  =  Third line of message  (may be nul = "")
  686. *--               cColor  =  Colors for window/menu/box
  687. *-------------------------------------------------------------------------------
  688.  
  689.     parameter lAnswer,cWhere,cMess1,cMess2,cMess3,cColor
  690.     private cExact,cW1,cW2,nULB,nBRR,nULC,nBRC,nLMargin,nRMargin,lWrap
  691.         
  692.     cExact = set("EXACT")
  693.     save screen to sYesno
  694.     
  695.     *-- see what the user gave us ...
  696.     if len(trim(cWhere)) > 0
  697.         cW1 = upper(left(cWhere,1))  && first coordinate (vertical)
  698.         cW2 = upper(right(cWhere,1)) && second coordinate (horizontal)
  699.     else
  700.         cW1 = "C"
  701.         cW2 = "C"
  702.     endif
  703.     *-- deal with vertical placement
  704.     do case
  705.         case cW1 = "U"
  706.             nULR =  1   && upper left row
  707.             nBRR =  8   && bottom right row
  708.         case cW1 = "C"
  709.             nULR =  8
  710.             nBRR = 15
  711.         case cW1 = "B"
  712.             nULR = 15
  713.             nBRR = 22
  714.     endcase
  715.     *-- deal with horizontal placement
  716.     do case
  717.         case cW2 = "L"
  718.             nULC =  5   && upper left column
  719.             nBRC = 45   && bottom right column
  720.         case cW2 = "R"
  721.             nULC = 35
  722.             nBRC = 75
  723.         case cW2 = "C"
  724.             nULC = 20
  725.             nBRC = 60
  726.     endcase
  727.     
  728.     activate screen
  729.     define window wYesno from nULR,nULC to nBRR,nBRC double color &cColor
  730.     
  731.     define menu mYesno
  732.     *-- remove && from MESSAGE option if using or might be used on Mono system
  733.     define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
  734.     define pad pNo  of mYesno Prompt "[No]"  at 5,25 && message "No"
  735.     on selection pad pYes of mYesno deactivate menu
  736.     on selection pad pNo  of mYesno deactivate menu
  737.     *-- start displaying it ... shadow, window ...
  738.     do shadow with nULR,nULC,nBRR,nBRC
  739.     activate window wYesno
  740.     *-- store or set some system values
  741.     nLmargin = _lmargin    
  742.     nRmargin = _rmargin
  743.     lWrap    = _wrap
  744.     _lmargin   = 2            && set local values
  745.     _rmargin   = 38
  746.     _wrap      = .t.
  747.     *-- display text
  748.     do center with 0,38,"",cMess1        && center the text
  749.     do center with 2,38,"",cMess2
  750.     do center with 3,38,"",cMess3
  751.     *-- set 'y' or 'n' keys ...
  752.    on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
  753.    on key label N keyboard IIF( PAD() = "PNO",  "", CHR(4)  )+chr(13)
  754.     clear typeahead
  755.    if lAnswer
  756.         activate menu mYesno pad pYes
  757.     else
  758.         activate menu mYesno pad pNo
  759.     endif
  760.    
  761.     *-- reset system ...
  762.     on key label Y
  763.    on key label N
  764.     _lmargin = nLmargin
  765.     _rmargin = nRmargin
  766.     _wrap    = lWrap
  767.     deactivate window wYesno
  768.     release window wYesno
  769.     restore screen from sYesno
  770.     release screen sYesno
  771.     release menu mYesno
  772.     set exact &cExact
  773.     
  774. RETURN iif(pad()="PYES",.t.,.f.)
  775. *-- EoF: YesNo2()
  776.  
  777. FUNCTION ErrorMsg
  778. *-------------------------------------------------------------------------------
  779. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  780. *-- Date........: 06/08/1992
  781. *-- Notes.......: Display an error message in a Window: 
  782. *--                           ** ERROR [#] **
  783. *--
  784. *--                              Message 1
  785. *--                              Message 2
  786. *--                       Press any key to continue ...
  787. *-- Written for.: dBASE IV, 1.1
  788. *-- Rev. History: 06/08/1992 -- Modified for explicit color handing.
  789. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  790. *--               CENTER               Procedure in PROC.PRG
  791. *--               ALLTRIM()            Function in PROC.PRG
  792. *-- Called by...: Any
  793. *-- Usage.......: ErrorMsg("<cErr>","<cMess1>","<cMess2>","<cColor>")
  794. *-- Example.....: lc_Dummy = errormsg("3","This record","already exists!",;
  795. *--                   "rg+/r,rg+/r,rg+/r")
  796. *--               where "errornum" is an error number or nul,
  797. *--               message2 and 3 should be 36 characters or less ...
  798. *--               Colors should include foreground/background,;
  799. *--                 foreground/background,foreground/background
  800. *-- Returns.....: numeric value of keystroke user presses (cUser)
  801. *-- Parameters..: cErr   = Error # (can be blank, but use "" for blank)
  802. *--               cMess1 = Error message line 1
  803. *--               cMess2 = Error message line 2
  804. *--               cColor = Colors for text/window/border
  805. *-------------------------------------------------------------------------------
  806.     
  807.     parameters cErr,cMess1,cMess2,cColor
  808.     private cCursor,cUser,cCurColor,cTempCol
  809.     
  810.     save screen to sErr
  811.     activate screen
  812.     define window wErr from 8,20 to 15,60 double color &cColor
  813.     do shadow with 8,20,15,60
  814.     activate window wErr
  815.     
  816.     cCursor = set("CURSOR")
  817.     set cursor off
  818.     if len(trim(cErr)) > 0  && if there's an error number ...
  819.         do center with 0,38,"","** ERROR "+alltrim(cErr)+" **"
  820.     else                      && otherwise, don't display errornumber
  821.         do center with 0,38,"","** ERROR **"
  822.     endif
  823.     do center with 2,38,"",cMess1
  824.     do center with 3,38,"",cMess2
  825.     do center with 5,38,"","Press any key to continue ..."
  826.     cUser=inkey(0)
  827.     
  828.     set cursor &cCursor
  829.     deactivate window wErr
  830.     release window wErr
  831.     restore screen from sErr
  832.     release screen sErr
  833.     
  834. RETURN cUser
  835. *-- EoF: ErrorMsg()
  836.  
  837. PROCEDURE ProgBar
  838. *-------------------------------------------------------------------------------
  839. *-- Programmer..: Joey D. Carroll (JOEY)
  840. *-- Date........: 06/28/1992
  841. *-- Notes.......: A visual indicator of program activity, i.e. shows
  842. *--               user program didn't die during long processes which
  843. *--               do not normally show 'on screen'.  Serves same purpose
  844. *--               as MONITOR, but is more graphic.
  845. *--               For best appearance, set cursor 'off' from calling
  846. *--               program, outside of the loop which calls PROGBAR.
  847. *-- Written for.: dBASE IV, 1.5
  848. *-- Rev. History: 10/26/1992 - Fixed bug(feature) so that cMessage prints the 
  849. *--                 color requested by cWindCol. Protected existing active 
  850. *--                 Window. (Joey Carroll)
  851. *-- Calls.......: None
  852. *-- Called by...: Any
  853. *-- Usage.......: do PROGBAR with <nQuan>,<cWindCol>,<cFillCol1>,cFillCol2>, ;
  854. *--                   <cMessage>,<nWindWidth>
  855. *-- Example.....: *-- determine what process will be monitored and what the
  856. *--               *-- final value will be, e.g. nReccount = reccount()
  857. *--               use <anyfile>
  858. *--               nReccount = reccount()
  859. *--               set cursor off
  860. *--               scan
  861. *--                  do progbar with nReccount,",,w+/n","w+/r","w+/g", ;
  862. *--                     "Processing records.  Be patient.",40
  863. *--                  *-- do some needed process here
  864. *--               endscan
  865. *--               *-- cleanup
  866. *-- Returns.....: None
  867. *-- Parameters..: nQuan     = maximum number of iterations
  868. *--               cWindCol  = the window colors
  869. *--               cFillCol1 = color of ruler before process
  870. *--               cFillCol2 = color of ruler after process
  871. *--               cMessage  = message displayed to user, may be "".
  872. *--               nWindWid  = (optional) desired width of ruler window.  If
  873. *--                               not specified, width of screen.  If
  874. *--                               specified, will not be less than length of
  875. *--                               message.
  876. *-------------------------------------------------------------------------------
  877.  
  878.    parameters nQuan,cWindCol,cFillCol1,cFillCol2,cMessage,nWindWidth
  879.    private lMessage,x, nParms
  880.    lMessage  = iif(.not. isblank(cMessage), .t., .f.)  && was message passed?
  881.     *-- find out # of parameters passed ...
  882.     if val(right(version(),3)) > 1.1
  883.         nParms = pcount()
  884.     else
  885.         nParms = 6
  886.     endif
  887.    nWindWidth = iif(nParms = 6,nWindWidth,78) && all the way if width not passed
  888.    nWindWidth = min(nWindWidth,78)            && width param > 78 not allowed
  889.    *-- window width can't be narrower than messsage, so....
  890.    nWindWidth = iif(lMessage,max(nWindWidth,len(cMessage) + 2),nWindWidth)
  891.    *-- skip this section if we've been here before
  892.    *-- this procedure called from inside a loop
  893.    *-- following section ignored except on first iteration thru loop
  894.    if type("nTimes") = "U"  && check to see if we been here before
  895.       save screen to sProgBar
  896.       public nFactor,nTimes,wPrevWind  && make these available on all iterations
  897.        *-- was a window active?
  898.        wPrevWind = window()
  899.       nProgLine = iif(set("status") = "ON",20,22)  && don't overwrite status
  900.       *-- determine how wide the window needs to be
  901.       define window wProgBar from ;
  902.          nProgLine - iif(lMessage, 2, 1),(80 - (nWindWidth + 2)) / 2 ;
  903.          to nProgLine + 1,(80 + (nWindWidth + 2)) / 2 - 1 ;
  904.          double color &cWindCol
  905.       activate window wProgBar
  906.       @ 0,0 say replicate(".",nWindWidth - 1)  && the ruler
  907.       @ 0,0 say "0%"                        && and some gradation %'s
  908.       @ 0,nWindWidth / 4 - 2 say "25%"
  909.       @ 0,nWindWidth / 2 - 2 say "50%"
  910.       @ 0,3*(nWindWidth / 4) - 2 say "75%"
  911.       @ 0,nWindWidth - 4 say "100%"
  912.       @ 0,0 fill to 0,nWindWidth - 1 color &cFillCol1  && color of ruler before process
  913.       if lMessage
  914.          @ 1,(nWindWidth - (len(cMessage))) / 2 say cMessage 
  915.       endif
  916.       nFactor = nQuan/nWindWidth   && e.g. how many records per bar part(cols)
  917.       nTimes = 0  && times thru loop
  918.    endif      && type("nTimes") = "U"
  919.  
  920.    *-- this section will be processed as many times as required by nQuan
  921.    nTimes = nTimes + 1
  922.    @ 0,0 fill to 0,int(nTimes / nFactor) ;
  923.          - iif(int(nTimes / nFactor) - 1 >= 0, 1, 0) ;
  924.          color &cFillCol2    && color of ruler as processing takes place
  925.    if nTimes = nQuan  && we done
  926.       x = inkey(.5)   && leave on screen just a liitle while after completion
  927.       *-- cleanup your mess
  928.       deactivate window wProgBar
  929.       release window wProgBar
  930.       restore screen from sProgBar
  931.       release screen sProgBar
  932.         *-- Reactivate window if it existed
  933.         if .not. isblank(wPrevWind)
  934.             activate window &wPrevWind
  935.         endif
  936.       release nProgBar,nFactor,nTimes,lMessage,x,wPrevWind
  937.    endif  && nTimes = nQuan
  938. RETURN
  939. *-- EoP: ProgBar
  940.  
  941. FUNCTION Alert2
  942. *-------------------------------------------------------------------------------
  943. *-- Programmer..: Adam L. Menkes (SUPREME1)
  944. *-- Date........: 11/16/1992
  945. *-- Notes.......: This function based on Alert2()
  946. *--               This routine creates a popup on the screen with a title and
  947. *--               one line message, forcing the user to notice the message.
  948. *--               The user must use the mouse on the 'OK' pad, press <Esc> or
  949. *--               press <Enter> to move on in the program that called this
  950. *--               function.
  951. *-- Written for.: dBASE IV, 1.5
  952. *-- Rev. History: Alert2()
  953. *--               Modified to accept the <Enter> key by Ken Mayer.
  954. *--               06/19/1992 -- Copied from Adam's original, uses a window,
  955. *--                 shadow, and programmer defineable colors.
  956. *--               07/29/1992 -- Joey stepped in and made some modifications
  957. *--                 that seem to have helped as well, including dealing with
  958. *--                 the keyboard buffer.
  959. *--               10/09/1992 -- minor change -- title is now same color as
  960. *--                 the "pad".
  961. *--               Alert22()
  962. *--               11/12/1992 -- changed to look more like a Win 3.0/3.1
  963. *--                 window by printing a special 'line' below the title.
  964. *--                 Also removed hard coding which forced border to DOUBLE
  965. *--                 so that if called with border set to NONE, gives even more
  966. *--                 Win-like appearance.  Calls a new function written for this
  967. *--                 technique, but can be used in other programs.
  968. *--               11/16/1992 -- modified to add cBORDER parameter ... (K. Mayer)
  969. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  970. *--               CENTER               Procedure in PROC.PRG
  971. *--               JUSTIFY()            Function in PROC.PRG
  972. *--               COLORBRK()           Function in PROC.PRG
  973. *--               FBCLRBRK()           Function in PROC.PRG 
  974. *-- Called by...: Any
  975. *-- Usage.......: Alert2("<cTitle>","<cMessage>","<cColor>"[,"<cBorder>"])
  976. *-- Example.....: ** if no border, I suggest colors which will contrast
  977. *--                  with the active screen or window
  978. *--               lX = Alert2("Print Aborted","You pressed <ESC>",;
  979. *--                           "rg+/r,w+/b,rg+/r","NONE")
  980. *-- Returns.....: Logical
  981. *-- Parameters..: cTitle   = Title line
  982. *--               cMessage = One line message (up to 75 characters)
  983. *--               cColor   = Colors: <window forg/back>,<pad> (and title),<box>
  984. *--               cBorder  = Border type (DOUBLE, SINGLE, NONE, PANEL) -- 
  985. *--                          optional -- will default to your setting
  986. *-------------------------------------------------------------------------------
  987.  
  988.    parameters cTitle, cMessage, cColor, cBorder
  989.    private wWindow,nRow,nCol,mPad,cTempCol,cColorF,cColorB,cColorAll,lNoBorder
  990.  
  991.    wWindow = WINDOW()                  && save current Window
  992.    save screen to sTemp                && save the screen
  993.    activate screen
  994.    cDummykey = inkey()                 && clear out keyboard buffer
  995.     cOldBorder = set("BORDER")       && get old border setting
  996.     if .not. type("CBORDER") = "L"      && if user set border ...
  997.         set border to &cBorder           && start NEW border setting
  998.     endif
  999.    lNoBorder = set("BORDER") = "NONE"  && is there a border?
  1000.  
  1001.    *-- get window coordinates
  1002.    *-- this centers from top to bottom, depending on monitor setup ...
  1003.    nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8)
  1004.    *-- add rows, number depends on border, so the Window is large enough ...
  1005.    if lNoBorder
  1006.       nBRRow = nULRow + 4
  1007.    else
  1008.       nBRRow = nULRow + 6
  1009.    endif
  1010.    *-- left column ...
  1011.    nULCol = 36 - (max(len(cTitle),len(cMessage))/2)    && center left-right
  1012.    *-- right column ...
  1013.    nBRCol = nULCol + max(len(cTitle),len(cMessage))+4  && right side?
  1014.    *-- Window width ...
  1015.    nWidth = nBRCol - nULCol - 1
  1016.  
  1017.    *-- define window
  1018.    activate screen
  1019.  
  1020.    Define window wAlert from nULRow,nULCol to nBRRow,nBRCol ;
  1021.            color &cColor.
  1022.  
  1023.    *-- display shadow
  1024.    do shadow with nULRow,nULCol,nBRRow,nBRCol
  1025.  
  1026.    *-- start 'er up ...
  1027.    activate window wAlert
  1028.  
  1029.    *-- display title
  1030.    cTempCol = colorbrk(cColor,2)
  1031.    if len(cTitle) < nWidth
  1032.        cTitle = justify(cTitle,iif(lNoBorder,nWidth+2,nWidth),"C")
  1033.        if len(cTitle) < nWidth
  1034.            cTitle = cTitle + " "
  1035.        endif
  1036.    endif
  1037.  
  1038.    *-- display  a new type type line to look more like Win
  1039.    cColorF   = FBClrBrk("B",cTempCol)
  1040.    cColorB   = FBClrBrk("B",colorbrk(cColor,1))
  1041.    cColorAll = cColorF + "/" + cColorB
  1042.    if lNoBorder
  1043.      do center with 0,nWidth + 3,"&cTempCol",cTitle
  1044.      *-- chr(223) looks like this --> ▀ <--
  1045.      @ 1,0 say replicate(chr(223),nWidth + 2) color &cColorAll
  1046.    else
  1047.      do center with 0,nWidth,"&cTempCol",cTitle
  1048.      @ 1,0 say replicate(chr(223),nWidth) color &cColorAll
  1049.    endif
  1050.  
  1051.    *-- display message
  1052.    do center with 2,nWidth,"",cMessage
  1053.  
  1054.    *-- define/display a very small menu (one pad)
  1055.    define menu mAlert
  1056.    define pad pPad1 of mAlert prompt "[OK]" at 4,(nWidth/2-2)
  1057.    on selection pad pPad1 of mAlert deactivate menu
  1058.  
  1059.    *-- added by Ken to deal with <Enter>
  1060.    on key label ctrl-M keyboard "{27}"
  1061.  
  1062.    *-- start it up
  1063.    activate menu mAlert
  1064.  
  1065.    *-- deal with user 'input'
  1066.    mPad = pad()
  1067.    deactivate window wAlert
  1068.    release window wAlert
  1069.  
  1070.    *-- restore environment, free up RAM by releasing things
  1071.    on key label ctrl-m
  1072.    restore screen from sTemp
  1073.    release screen sTemp
  1074.    release menu mAlert
  1075.    if "" # wWindow
  1076.        activate window &wWindow
  1077.    endif
  1078.     set border to &cOldBorder
  1079.     
  1080. RETURN .not. "" = mPad  && not empty pad?
  1081. *-- EoF: Alert2()
  1082.  
  1083. PROCEDURE Shadow
  1084. *-------------------------------------------------------------------------------
  1085. *-- Programmer..: Ashton-Tate
  1086. *-- Date........: 01/27/1992
  1087. *-- Notes.......: Creates a shadow for a window (taken from the dBASE IV
  1088. *--               picklist functions)
  1089. *-- Written for.: dBASE IV, 1.1
  1090. *-- Rev. History: 05/23/1991 - original procedure.
  1091. *--               12/14/1991 - Modified by Jim Magnant (TXAGGIE) - to check
  1092. *--               for columns exceeding 79, and temporarily change last col.
  1093. *--               value (so routine doesn't "blow up").
  1094. *--               01/27/1992 -- Modifiedy by Ken Mayer to check for bottom
  1095. *--               of screen, based on what Jim did above. No further than 23.
  1096. *-- Calls.......: None
  1097. *-- Called by...: Too many to list ...
  1098. *-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  1099. *-- Example.....: save screen to sMain
  1100. *--               activate screen
  1101. *--               define window wError from 5,15 to 15,65 double color;
  1102. *--                    rg+/r,rg+/r,rg+/r
  1103. *--               do shadow with 5,15,15,65
  1104. *--               activate window WError
  1105. *--                && perform actions in window
  1106. *--               deactivate window WError
  1107. *--               release window WError
  1108. *--               restore screen from sMain
  1109. *--               release screen sMain
  1110. *-- Returns.....: None
  1111. *-- Parameters..: nULRow = Upper Left Row position
  1112. *--               nULCol = Upper Left Column position (x,y)
  1113. *--               nBRRow = Bottom Right Row position
  1114. *--               nBRCol = Bottom Right Column position (x2,y2)
  1115. *-------------------------------------------------------------------------------
  1116.  
  1117.     parameters nULRow,nULCol,nBRRow,nBRCOL
  1118.     private nTempRow,nTempCol,nIncRow,nIncCol
  1119.  
  1120.     nTempRow = iif(nBRRow+1>23,23,nBRRow+1)
  1121.     nTempCol = iif(nBRCol+2>79,79,nBRCol+2)
  1122.     nIncRow = 1
  1123.     nIncCol = (nBRCol-nULCol) / (nBRRow-nULRow)
  1124.     do while nTempRow <> nULRow .or. nTempCol <> nULCol+2
  1125.         nRightCol = nBRCol
  1126.         nBRCol = iif(nBRCol + 2 > 79,77,nBRCol)
  1127.         nBotRow = nBRRow
  1128.         nBRRow = iif(nBRRow + 1 > 23,22,nBRRow)
  1129.         @ nTempRow,nTempCol fill to nBRRow+1,nBRCol+2 color n+/n
  1130.         nBRCol = nRightCol
  1131.         nBRRow = nBotRow
  1132.         nTempRow = iif(nTempRow<>nULRow,nTempRow - nIncRow,nTempRow)
  1133.         nTempCol = iif(nTempCol<>nULCol+2,nTempCol - nIncCol,nTempCol)
  1134.         nTempCol = iif(nTempCol<nULCol+2,nULCol+2,nTempCol)
  1135.     enddo
  1136.     
  1137. RETURN
  1138. *-- EoP: Shadow
  1139.  
  1140. FUNCTION VPick
  1141. *-------------------------------------------------------------------------------
  1142. *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
  1143. *-- Date........: 06/08/1992
  1144. *-- Notes.......: Keith wanted a multiple choice picklist routine for use
  1145. *--               with a mouse (or other) ... he got the idea for the AT-USER
  1146. *--               system which he was Beta Testing. Here 'tis ...
  1147. *--                This creates a quick pick-list for multiple-choice, single-
  1148. *--                character input. The first letter of the selected bar is
  1149. *--                returned. If <Esc> is pressed, a null string is returned.
  1150. *--               NOTE: If using this with dBASE IV, 1.1, you must supply
  1151. *--               a parameter for each option below.
  1152. *-- Written for.: dBASE IV, 1.5
  1153. *-- Rev. History: 06/02/1992 -- Keith first gave this to Ken Mayer to use with
  1154. *--               the BORUSER system.
  1155. *--               06/08/1992 -- Modified to allow passing of a color memvar,
  1156. *--               and then to use explicit color definitions based on it.
  1157. *--               11/09/1992 - Joey Carrol modified to allow use of function
  1158. *--               when another window is active, and to insure color integrity
  1159. *-- Calls.......: COLORBRK()          Function in PROC.PRG
  1160. *--               RECOLOR             Procedure in PROC.PRG
  1161. *-- Called by...: Any
  1162. *-- Usage.......: ?VPick(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>",;
  1163. *--                 <lShadow>,<cColor>)
  1164. *-- Example.....: cHow = VPick(12,15,"~BorBBS ID~Lastname",;
  1165. *--                        "How do you want the data sorted?","Choose one",;
  1166. *--                        "rg+/gb,w+/b,rg+/gb")
  1167. *-- Returns.....: First letter of bar selected, or null if <Esc>.
  1168. *-- Parameters..: nRow     = is a numeric value for the top row of the popup.
  1169. *--               nCol     = is a numeric value for the left column.
  1170. *--               cOptions = is a string of options with each preceded by
  1171. *--                       '~', e.g. "~Screen~Printer~Text File~Return to Menu"
  1172. *--               cTitle   = is an optional title, used for the popup heading
  1173. *--               cMessage = is an optional message string for when the popup 
  1174. *--                          is activated on the screen.
  1175. *--               lShadow  = is a logical value indicating whether or not a 
  1176. *--                          shadow is to be placed under the popup.
  1177. *--               cColor   = Colors to be used. Should have three parts --
  1178. *--                          <normal/unselected text>,<highlighted text>,
  1179. *--                          <border>, using the format "Foreground/Background"
  1180. *--                          for each. So examine the example above.
  1181. *-------------------------------------------------------------------------------
  1182.     
  1183.     parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow,cColor
  1184.     private nRow,nCol,cOptions,cTitle,cMessage,lShadow,cTempCol,cCurColor
  1185.     
  1186.     *-- get number of parameters, and a few setup steps ...
  1187.     if val(right(version(),3)) > 1.1  && if version of dBASE (RunTime) > 1.1
  1188.        nParameters = pcount()
  1189.     else
  1190.         nParameters = 7
  1191.     endif
  1192.    nCount = 0
  1193.    cReturn = ""
  1194.    cOptions = trim(cOptions)
  1195.    cDispMesg = ""
  1196.    *-- if number of parameters greater/equal to 5, we may have a message
  1197.    *-- at the bottom of the screen ...
  1198.    if nParameters >= 5
  1199.       if len(cMessage) > 0
  1200.          cDispMesg = "MESSAGE "+"'"+cMessage+"'"
  1201.       endif
  1202.    endif
  1203.    
  1204.    *-- make it work even if a window is active.
  1205.    wPrevWind = window()
  1206.    activate screen
  1207.  
  1208.    *-- define the popup
  1209.    define popup pPickList from nRow,nCol &cDispMesg.
  1210.    nMessage1 = 0
  1211.    *-- if we have 4 or more parameters, one of them is the title ...
  1212.    *-- this requires that the first two bars of the menu be skipped ...
  1213.    if nParameters >= 4
  1214.       if len(cTitle) > 0
  1215.          cTitle = " "+cTitle+" "
  1216.          nMessage1 = len(cTitle)
  1217.          nCount = 2
  1218.       endif
  1219.    endif
  1220.  
  1221.     *-- save current colors
  1222.     cCurColor = set("ATTRIBUTES")
  1223.     *-- set new ones
  1224.     cTempCol = colorbrk(cColor,1)
  1225.     set color of normal  to &cTempCol
  1226.     set color of message to &cTempCol
  1227.     cTempCol = colorbrk(cColor,2)
  1228.     set color of highlight to &cTempCol
  1229.     cTempCol = colorbrk(cColor,3)
  1230.     set color of box to &cTempCol
  1231.     
  1232.    *-- now we start parsing the options for the menu. These must have
  1233.    *-- a tilde between each, so we look for the first one, and then
  1234.    *-- look again to see if there's another after that.
  1235.  
  1236.    nPos1 = at("~",cOptions)                        && Look for first tilde
  1237.    do while (len(cOptions) > 0) .and. (nPos1 > 0)  && parsing loop ...
  1238.       if nPos1 > 0
  1239.          cSub = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
  1240.          nPos2 = at("~",cSub)
  1241.          if nPos2 = 0
  1242.             nPos2 = len(cSub)
  1243.          else
  1244.             nPos2 = nPos2 - 1
  1245.          endif
  1246.          cOptString = " "+left(cSub,nPos2)+" "
  1247.          if len(cOptString) > nMessage1
  1248.             nMessage1 = len(cOptString)
  1249.          endif
  1250.          *-- define the actual 'bar' of the menu/picklist ...
  1251.          nCount = nCount + 1
  1252.          define bar nCount of pPickList prompt cOptString
  1253.          cOptions = cSub
  1254.       endif
  1255.       nPos1 = at("~",cOptions)
  1256.    enddo  && end of parsing loop
  1257.  
  1258.    *-- now we deal with defining the actual picklist ...
  1259.    if nCount > 0             && if we have something to put in the list ...
  1260.       if nParameters >= 4    && if we have a title for the top ...
  1261.          if len(cTitle) > 0
  1262.             if len(cTitle) < nMessage1
  1263.                cTitle = trim(ltrim(cTitle))
  1264.                cTitle = space((nMessage1-len(cTitle)) / 2) + cTitle
  1265.             endif
  1266.             define bar 1 of pPickList prompt cTitle skip
  1267.             define bar 2 of pPickList prompt replicate(chr(196),nMessage1) skip
  1268.          endif
  1269.       endif
  1270.       *-- define what to do when a choice is made ...
  1271.       on selection popup pPickList deactivate popup
  1272.       *-- if we have a shadow, let's save screen and do the shadow
  1273.       *-- before popping up the picklist
  1274.         if nParameters => 6
  1275.           if lShadow
  1276.              save screen to sPickScr
  1277.              @ nRow+1,nCol+2 fill to nRow+nCount+2,nCol+nMessage1+3 color w/n
  1278.           endif
  1279.         else
  1280.             lShadow = .f.
  1281.         endif
  1282.       *-- there we are ...
  1283.       activate popup pPickList
  1284.  
  1285.       *-- cleanup
  1286.       if lShadow
  1287.         restore screen from sPickScr
  1288.         release screen sPickScr
  1289.       endif
  1290.  
  1291.       *-- deal with what to 'return' ...
  1292.       if lastkey() = 27
  1293.          cReturn = ""
  1294.       else
  1295.          cReturn = substr(prompt(),2,1)
  1296.       endif
  1297.  
  1298.    endif && nCount > 0
  1299.  
  1300.     *-- we're done with it ... return it back to the electronic byte storage
  1301.     *-- bins ... 
  1302.    release popup pPickList
  1303.     do ReColor with cCurColor
  1304.     
  1305.     *-- was there an existing window?
  1306.     if .not. isblank(wPrevWind)
  1307.         activate window &wPrevWind
  1308.     endif
  1309.     
  1310. RETURN cReturn
  1311. *-- EoF: VPick()
  1312.  
  1313. FUNCTION HPick
  1314. *-------------------------------------------------------------------------------
  1315. *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
  1316. *-- Date........: 06/12/1992
  1317. *-- Notes.......: Creates a horizontal pick list for multiple-choice single-
  1318. *--               character input.  The first letter of the selected pad is 
  1319. *--               returned.  If <ESC> is pressed, a null string is returned.
  1320. *-- Written for.: dBASE IV, 1.1, 1.5
  1321. *-- Rev. History: 11/09/1992 - Modified to allow use when another window is
  1322. *--                active, and to ensure color integrity (Joey Carroll).
  1323. *-- Calls.......: COLORBRK()           Function in PROC.PRG
  1324. *--               RECOLOR              Procedure in PROC.PRG
  1325. *-- Called by...: Any
  1326. *-- Usage.......: HPICK(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>";
  1327. *--                     <lShadow>,"<cColor>")
  1328. *-- Example.....: x=HPick(8,5,"~Screen~Printer~Text File~Return to Menu",;
  1329. *--                       "Output Options","Select one, or <Esc> to exit",;
  1330. *--                       .t.,"rg+/gb,w+/b,rg+/gb")
  1331. *-- Returns.....: First letter of selected 'pad', or null if <Esc>.
  1332. *-- Parameters..: nRow      = a numeric value for the top row of the popup.
  1333. *--               nCol      = a numeric value for the left column of the popup.
  1334. *--               cOptions  = a string of options with each preceded by '~',
  1335. *--                           e.g. "~Screen~Printer~Text File~Return to Menu"
  1336. *--               cTitle    = an optional title, used for the popup heading
  1337. *--               cMessage  = an optional message string for when the popup 
  1338. *--                           is activated on the screen.
  1339. *--               lShadow   = a logical value indicating whether or not a 
  1340. *--                           shadow is to be placed under the popup.
  1341. *--               cColor    = Colors passed to function in format:
  1342. *--                            <Text/Unselected Pad>,<Selected Pad>,<Border>
  1343. *-------------------------------------------------------------------------------
  1344.  
  1345.     parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow, cColor
  1346.     private cPickColor,cTempCol
  1347.    *-- get number of parameters, and a few setup steps
  1348.     *-- if version 1.5 or later, # of parms is optional ...
  1349.     if val(right(version(),3)) > 1.1  && if version of dBASE > 1.1
  1350.         nParameters = pcount()
  1351.     else
  1352.         nParameters = 7
  1353.     endif
  1354.    nCount = 0
  1355.    nStartCol = nCol
  1356.    cOptions = trim(cOptions)
  1357.    cDispMess = ""
  1358.     
  1359.     *-- make it work even if a window is active
  1360.     wPrevWind = window()
  1361.     activate screen
  1362.     
  1363.     *-- save current colors, set up colors for this routine
  1364.     cPickColor = set("ATTRIBUTES")
  1365.     cTempCol = colorbrk(cColor,1)
  1366.     set color of normal to &cTempCol
  1367.     set color of message to &cTempCol
  1368.     cTempCol = colorbrk(cColor,2)
  1369.     set color of highlight to &cTempCol
  1370.     cTempCol = colorbrk(cColor,3)
  1371.     set color of box to &cTempCol
  1372.     
  1373.    cPadName = "p"
  1374.     *-- if # of parameters => 5, we may have a message at the bottom of the
  1375.     *-- screen ...
  1376.    if nParameters >= 5
  1377.       if len(cMessage) > 0
  1378.          cDispMess = "MESSAGE "+"'"+cMessage+"'"
  1379.       endif
  1380.    endif
  1381.     *-- start defining the menu ...
  1382.    define menu mHPick &cDispMess.
  1383.    if nParameters >= 4
  1384.       if len(cTitle) > 0
  1385.          cTitle = " "+cTitle+" "
  1386.       endif
  1387.    endif
  1388.     
  1389.     *-- here, we have to parse the cOptions field for the tilde "~" character,
  1390.     *-- which is how we know we have a new pad ...
  1391.    nPos1 = at("~",cOptions)                        && position of first tilde
  1392.    do while (len(cOptions) > 0) .and. (nPos1 > 0)  && parsing loop
  1393.       if nPos1 = 0 .and. (len(cOptions) > 0)
  1394.          nPos1 = len(cOptions)
  1395.       endif
  1396.       if nPos1 > 0
  1397.          cSubString = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
  1398.          nPos2 = at("~",cSubString)
  1399.          if nPos2 = 0
  1400.             nPos2 = len(cSubString)
  1401.          else
  1402.             nPos2 = nPos2 - 1
  1403.          endif
  1404.          cOptString = " "+left(cSubString,nPos2)+" "
  1405.          nCount = nCount + 1
  1406.          cPadName = "p"+ltrim(trim(str(nCount)))
  1407.          define pad &cPadName of mHPick prompt cOptString at nRow,nCol
  1408.          nCol = nCol + len(cOptString)
  1409.          on selection pad &cPadName of mHPick deactivate menu
  1410.          cOptions = cSubString
  1411.       endif
  1412.       nPos1 = at("~",cOptions)
  1413.    enddo
  1414.  
  1415.     *-- done figure that out. On to more stuff ...
  1416.    save screen to sPickList
  1417.     *-- do we have a shadow?
  1418.    if lShadow
  1419.       @ nRow,nStartCol+2 fill to nRow+2,nCol+2
  1420.    endif
  1421.     *-- draw border
  1422.    @ nRow-1,nStartCol-1 to nRow+1,nCol
  1423.     *-- display 'title'
  1424.    if len(cTitle) > 0
  1425.       @ nRow-1,nStartCol+1 say cTitle
  1426.    endif
  1427.     *-- start 'er up ...
  1428.    activate menu mHPick
  1429.  
  1430.     *-- that's it ... return screen to it's original
  1431.     *-- state ...
  1432.    restore screen from sPickList
  1433.     release screen sPickList
  1434.     
  1435.     *-- deal with user keystroke/selection ...
  1436.    if lastkey() = 27
  1437.       cReturn = ""
  1438.    else
  1439.       cReturn = substr(prompt(),2,1)
  1440.    endif
  1441.  
  1442.     *-- cleanup.
  1443.    release menu mHPick
  1444.     do ReColor with cPickColor  && reset colors
  1445.  
  1446.     *-- was there an existing window?
  1447.     if .not. isblank(wPrevWind)
  1448.         activate window &wPrevWind
  1449.     endif
  1450.  
  1451. RETURN cReturn
  1452. *-- EoF: HPick()
  1453.  
  1454. *===============================================================================
  1455. * COLOR PROCESSING -- These routines handle setting colors, dealing with
  1456. * checking how colors are set, and so on. Anything that's not here is in
  1457. * the library file:  COLOR.PRG.
  1458. *===============================================================================
  1459.  
  1460. PROCEDURE SetColor
  1461. *-------------------------------------------------------------------------------
  1462. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1463. *-- Date........: 07/24/1992
  1464. *-- Notes.......: This routine is designed set colors of the primary "areas"
  1465. *--               on the screen, based on a color memvar being passed to it.
  1466. *--               This color memvar should contain two sets of colors (normal
  1467. *--               and enhanced). See below for more details. 
  1468. *-- Written for.: dBASE IV, 1.5
  1469. *-- Rev. History: None
  1470. *-- Calls.......: ColorBrk()           Function in PROC.PRG
  1471. *-- Called by...: Any
  1472. *-- Usage.......: do SetColor with <cColorVar>
  1473. *-- Example.....: cOldColor = set("ATTRIBUTES")  && save old colors
  1474. *--               do SetColor with cl_dialog
  1475. *--                 *-- do whatever needs to be done with these colors
  1476. *--               do ReColor with cOldColor      && restore old colors
  1477. *-- Returns.....: None
  1478. *-- Parameters..: cColorVar = Color memvar. This must contain a "normal"
  1479. *--                           color and a "highlight" color in the format:
  1480. *--                           <forg>/<back>,<forg>/<back>
  1481. *--                           i.e., "rg+/gb,w+/b"
  1482. *-------------------------------------------------------------------------------
  1483.  
  1484.     parameters cColorVar
  1485.     private cNormCol,cHighCol
  1486.     
  1487.     cNormCol = colorbrk(cColorVar,1)  && extract "normal" colors
  1488.     cHighCol = colorbrk(cColorVar,2)  && extract "highlight" colors
  1489.     
  1490.     set color of normal    to &cNormCol  && regular screen/text colors
  1491.     set color of messages  to &cNormCol  && messages/menu pads, etc.
  1492.     set color of box       to &cHighCol  && borders
  1493.     set color of fields    to &cHighCol  && data entry fields
  1494.     set color of highlight to &cHighCol  && highlighted items in menus, etc.
  1495.     
  1496. RETURN
  1497. *-- EoP: SetColor
  1498.  
  1499. PROCEDURE ReColor
  1500. *-------------------------------------------------------------------------------
  1501. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1502. *-- Date........: 04/23/1992
  1503. *-- Notes.......: Restores colors to those held in a string of the form
  1504. *--               returned by set("ATTRIBUTE").
  1505. *-- Written for.: dBASE IV, Versions 1.0 - 1.5.
  1506. *-- Rev. History: None
  1507. *-- Calls       : None
  1508. *-- Called by...: Any
  1509. *-- Usage.......: DO ReColor WITH <cColors>
  1510. *-- Example.....: DO Recolor WITH OldColors
  1511. *-- Parameters..: cColors, a string in the form returned by set("ATTRIBUTE").
  1512. *-- Side effects: Changes the screen colors.
  1513. *-------------------------------------------------------------------------------
  1514.  
  1515.   parameters cColors
  1516.   private cThis, cNext, nAt, cLeft, nX, cAreas
  1517.   cAreas = "   NORMHIGHBORDMESSTITLBOX INFOFIEL"
  1518.   cLeft = cColors + ", "
  1519.   nX = 0
  1520.   do while nX < 8
  1521.     nX = nX + 1
  1522.     cThis = substr( cAreas, 4 * nX, 4 )
  1523.     if nX = 3
  1524.       nAt = at( "&", cLeft )
  1525.       cNext = left( cLeft, nAt - 2 )
  1526.       cLeft = substr( cLeft, nAt + 3 )
  1527.       SET COLOR TO , , &cNext
  1528.     else
  1529.       nAt = at( ",", cLeft )
  1530.       cNext = left( cLeft, nAt - 1 )
  1531.       cLeft = substr( cLeft, nAt + 1 )
  1532.       SET COLOR OF &cThis TO &cNext
  1533.     endif
  1534.   enddo
  1535.  
  1536. RETURN
  1537. *-- EoP: ReColor
  1538.  
  1539. FUNCTION ColorBrk
  1540. *-------------------------------------------------------------------------------
  1541. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1542. *-- Date........: 07/22/1992
  1543. *-- Notes.......: This routine is designed to be used with any of my functions
  1544. *--               and procedures that accept a memory variable for color,
  1545. *--               and use a window. It's purpose is to break that color var
  1546. *--               into it's components (depending on which one the user wants)
  1547. *--               and return those components, so that they can then be used
  1548. *--               in SET COLOR OF ... commands.
  1549. *-- Written for.: dBASE IV, 1.1, 1.5 (written because of 1.5, but will work in
  1550. *--                1.1)
  1551. *-- Rev. History: 07/22/1992 - modified to handle memvars/color strings that
  1552. *--               may have only two parts to them (no <border>...), so that if
  1553. *--               the <nField> parm is 2, we get a valid value.
  1554. *-- Calls.......: None
  1555. *-- Called by...: Any
  1556. *-- Usage.......: ColorBrk(<cColorVar>,<nField>)
  1557. *-- Example.....: set color of normal to ColorBrk(cColor,1)
  1558. *-- Returns.....: Either the field you asked for (1 thru 3) or null string ("").
  1559. *-- Parameters..: cColorVar = Color variable to extract data from
  1560. *--                   Assumes the form: <main color>,<highlight>,<border>
  1561. *--                   Where each part uses: <foreground>/<background> format
  1562. *--                    i.e., rg+/gb,w+/b,rg+/gb
  1563. *--               nField    = Field you want to extract
  1564. *-------------------------------------------------------------------------------
  1565.  
  1566.     parameters cColorVar, nField
  1567.     private cReturn, cExtracted
  1568.     
  1569.     do case
  1570.         case nField = 1
  1571.             cReturn = left(cColorVar,at(",",cColorVar)-1)
  1572.         case nField = 2
  1573.             cExtract = substr(cColorVar,at(",",cColorVar)+1)  && everything to 
  1574.                                                               && right of comma
  1575.             if at(",",cExtract) > 0
  1576.                 cReturn = left(cExtract,at(",",cExtract)-1)    && left of second ,
  1577.             else
  1578.                 cReturn = cExtract
  1579.             endif
  1580.         case nField = 3
  1581.             cExtract = substr(cColorVar,at(",",cColorVar)+1)
  1582.             cReturn = substr(cExtract,at(",",cExtract)+1)
  1583.         otherwise
  1584.             cReturn = ""
  1585.     endcase
  1586.  
  1587. RETURN cReturn
  1588. *-- EoF: ColorBrk()
  1589.  
  1590. FUNCTION FBClrBrk
  1591. *------------------------------------------------------------------------------
  1592. *-- Programmer..: Joey D. Carroll (JOEY on USSBBS)
  1593. *-- Date........: 11/12/1992
  1594. *-- Notes.......: Extracts foreground/background colors from a string in the
  1595. *--                  form of a literal "n/gb" or of a variable.  It is useful
  1596. *--                  to use COLORBRK() to obtain this value.
  1597. *-- Written for.: dBASE IV, ver 1.5
  1598. *-- Rev. History: None
  1599. *-- Calls.......: None
  1600. *-- Called by...: Any
  1601. *-- Usage.......: ?? FBClrBrk("B","w+/gr")
  1602. *-- Example.....: cNormalClr = "w+/gr"
  1603. *--               cForeClr   = FBClrBrk("F",cNormalClr)   && = "w+"
  1604. *--               cBackClr   = FBClrBrk("B",cNormalClr)   && = "gr"
  1605. *-- Returns.....: a sub-string of cColor
  1606. *-- Parameters..: cType  = "F" for foreground color  "B" for Background
  1607. *--               cColor = the color you want to extract from
  1608. *------------------------------------------------------------------------------
  1609.    parameters cType,cColor
  1610.    private cRetClr
  1611.    if upper(cType) = "F"
  1612.       cRetClr = iif(at("/",cColor) = 0,cColor,left(cColor,at("/",cColor)-1))
  1613.    else           && = "B"
  1614.       cRetClr = substr(cColor,at("/",cColor) + 1,2)
  1615.    endif
  1616.  
  1617. RETURN cRetClr
  1618. *-- EoF: FBClrBrk()
  1619.  
  1620. *===============================================================================
  1621. * STRING Manipulation. Most of these are in the library file:  STRINGS.PRG
  1622. * The ones here are common to a lot of apps and functions, and are here so
  1623. * that the library STRINGS.PRG need not be called.
  1624. *===============================================================================
  1625.  
  1626. FUNCTION AllTrim
  1627. *-------------------------------------------------------------------------------
  1628. *-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain)
  1629. *-- Date........: 5/23/1991
  1630. *-- Notes.......: Complete trims edges of field (left and right)
  1631. *-- Written for.: dBASE IV, 1.1
  1632. *-- Rev. History: None
  1633. *-- Calls.......: None
  1634. *-- Called by...: Any
  1635. *-- Usage.......: alltrim(<cString>)
  1636. *-- Example.....: ? alltrim("  Test String  ") 
  1637. *-- Returns.....: Trimmed string, i.e.:"Test String"
  1638. *-- Parameters..: cString = string to be trimmed
  1639. *-------------------------------------------------------------------------------
  1640.     
  1641.     parameters cString
  1642.     
  1643. RETURN ltrim(rtrim(cString))
  1644. *-- EoF: AllTrim()
  1645.  
  1646. FUNCTION Justify
  1647. *-------------------------------------------------------------------------------
  1648. *-- Programmer..: Roland Bouchereau (Ashton-Tate)
  1649. *-- Date........: 12/23/1992
  1650. *-- Notes.......: Used to pad a field/string on the right, left or both,
  1651. *--               justifying or centering it within the length specified.
  1652. *--               If the length of the string passed is greater than
  1653. *--               the size needed, the function will truncate it. 
  1654. *--               Taken from Technotes, June 1990. Defaults to Left Justify
  1655. *--               if invalid TYPE is passed ...
  1656. *-- Written for.: dBASE IV, 1.0
  1657. *-- Rev. History: Original function 06/15/1991
  1658. *--               12/17/1991 -- Modified into ONE function from three by
  1659. *--                  Ken Mayer, added a third parameter to handle that.
  1660. *--               12/23/1992 -- Modified by Joey Carroll to use STUFF()
  1661. *--                  instead of TRANSFORM().
  1662. *-- Calls.......: None
  1663. *-- Called by...: Any
  1664. *-- Usage.......: Justify(<cFld>,<nLength>,"<cType>")
  1665. *-- Example.....: ?? Justify(Address,25,"R")
  1666. *-- Returns.....: Padded/truncated field
  1667. *-- Parameters..: cFld    =  Field/Memvar/Character String to justify
  1668. *--               nLength =  Width to justify within
  1669. *--               cType   =  Type of justification: L=Left, C=Center,R=Right
  1670. *-------------------------------------------------------------------------------
  1671.     
  1672.     parameters cFld,nLength,cType
  1673.     private cReturn
  1674.     
  1675.     cType = upper(cType)    && just making sure ...
  1676.     if type("cFld")+type("nLength")+type("cType") $ "CNC,CFC"
  1677.        *-- set a picture function of 'X's, with @I,@J or @B function
  1678.        cReturn = space(nLength)
  1679.         cReturn = stuff(cReturn,;
  1680.                         iif(cType = "C",(nLength-len(cFld))/2,;
  1681.                         iif(cType = "R",nLength-len(cFld)+1,1)),;
  1682.                         len(cFld),cFld)
  1683.     else
  1684.         cReturn = ""
  1685.     endif
  1686.  
  1687. RETURN cReturn
  1688. *-- EoF: Justify()
  1689.  
  1690. FUNCTION State
  1691. *-------------------------------------------------------------------------------
  1692. *-- Programmer..: David G. Franknbach (FRNKNBCH)
  1693. *-- Date........: 04/22/1992
  1694. *-- Notes.......: Validation of state codes -- used to ensure that a user
  1695. *--               doing data entry will enter the proper codes. Added a few
  1696. *--               US Territory codes as well (Puerto Rico, etc.)
  1697. *-- Written for.: dBASE IV, 1.1
  1698. *-- Rev. History: 12/02/1991
  1699. *--               03/11/1992 -- Modified by Ken Mayer to handle
  1700. *--               the extra US Territories, and to ensure that the data is
  1701. *--               at least temporarily in upper case when doing the check ...
  1702. *--               04/22/1992 -- Modified by Jay Parsons to shorten
  1703. *--               (simplify) the routine by removing the cSTATE2 memvar.
  1704. *-- Calls.......: None
  1705. *-- Called by...: None
  1706. *-- Usage.......: STATE(<cState>)
  1707. *-- Example.....: @5,10 get cState valid required state(cState);
  1708. *--                     error chr(7)+"This is not a valid state code!"
  1709. *-- Returns.....: Logical (.t. if found, .f. otherwise)
  1710. *-- Parameters..: cState = state code to be checked ....
  1711. *-------------------------------------------------------------------------------
  1712.  
  1713.     parameters cState
  1714.     
  1715.     cStateList = "AL|AK|AZ|AR|CA|CO|CT|DE|DC|FL|GA|HI|ID|IL|IN|IA|KS|KY|LA|"+;
  1716.                  "ME|MD|MA|MI|MN|MS|MO|MT|NE|NV|NH|NJ|NM|NY|NC|ND|OH|OK|OR|"+;
  1717.                  "PA|RI|SC|SD|TN|TX|UT|VT|VA|WA|WV|WI|WY|PR|AS|GU|CM|TT|VI|"
  1718.     lOK = upper(cState) $ cStateList
  1719.  
  1720. RETURN lOK
  1721. *-- EoF: State()
  1722.  
  1723. *===============================================================================
  1724. *  DATE HANDLING ROUTINES -- Most of these are now in the library file: 
  1725. *  DATES.PRG (included with this version of PROC). However, a few are below,
  1726. *  as they have become 'standard' routines in many of my systems.
  1727. *===============================================================================
  1728.  
  1729. FUNCTION DateText
  1730. *-------------------------------------------------------------------------------
  1731. *-- Programmer..: Miriam Liskin
  1732. *-- Date........: 05/23/1991
  1733. *-- Notes.......: Display date in format Month, day year (e.g., July 1,1991)
  1734. *-- Written for.: dBASE IV, 1.1
  1735. *-- Rev. History: None
  1736. *-- Calls.......: None
  1737. *-- Called by...: Any
  1738. *-- Usage.......: DateText(<dDate>) 
  1739. *-- Example.....: ? datetext(date())
  1740. *-- Returns.....: July 1, 1991
  1741. *-- Parameters..: dDate = date to be converted
  1742. *-------------------------------------------------------------------------------
  1743.  
  1744.     parameters dDate
  1745.     
  1746. RETURN CMONTH(dDate)+" "+ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
  1747. *-- EoF: DateText()
  1748.  
  1749. FUNCTION DateText2
  1750. *-------------------------------------------------------------------------------
  1751. *-- Programmer..: Miriam Liskin
  1752. *-- Date........: 05/23/1991
  1753. *-- Notes.......: Display date in format day-of-week, Month day, year
  1754. *-- Written for.: dBASE IV, 1.1
  1755. *-- Rev. History: None
  1756. *-- Calls.......: None
  1757. *-- Called by...: Any
  1758. *-- Usage.......: DateText2(<dDate>)
  1759. *-- Example.....: ? DateText2(date())
  1760. *-- Returns.....: Thursday, July 1, 1991
  1761. *-- Parameters..: dDate = date to be converted
  1762. *-------------------------------------------------------------------------------
  1763.  
  1764.     parameters dDate
  1765.     
  1766. RETURN CDOW(dDate)+", "+cmonth(dDate)+" "+;
  1767.        ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
  1768. *-- EoF: DateText2()
  1769.  
  1770. FUNCTION Age
  1771. *-------------------------------------------------------------------------------
  1772. *-- Programmer..: Martin Leon (HMAN)
  1773. *-- Date........: 10/23/91
  1774. *-- Notes.......: Returns age of person, given their birthdate as of DATE(),
  1775. *--               effectively, as of "Today".
  1776. *-- Written for.: dBASE IV, 1.1
  1777. *-- Rev. History: None
  1778. *-- Calls.......: None
  1779. *-- Called by...: Any
  1780. *-- Usage.......: Age(<dBDay>)
  1781. *-- Example.....: ? "Joe is "+ltrim(str(age(dBDay)))+" today ..."
  1782. *-- Returns.....: Numeric value in years
  1783. *-- Parameters..: dBDay = birthdate of person attempting to find age of.
  1784. *-------------------------------------------------------------------------------
  1785.  
  1786.     parameters dBDay
  1787.     private dToday,nYears
  1788.     
  1789.     dToday = date()
  1790.     nYears = year(dToday) - year(dBDay)
  1791.     do case
  1792.         case month(dBDay) > month(dToday)
  1793.             nYears = nYears - 1
  1794.         case month(dBDay) = month(dToday)
  1795.             if day(dBDay) > day(dToday)
  1796.                 nYears = nYears - 1
  1797.             endif
  1798.     endcase
  1799.  
  1800. RETURN nYears
  1801. *-- EoF: Age()
  1802.  
  1803. *===============================================================================
  1804. * FIELD HANDLING ROUTINES -- Unique searches, string manipulation ...
  1805. * The ones left in PROC.PRG are the more commonly used ones. Anything else is
  1806. * in the library file: FIELDS.PRG.
  1807. *===============================================================================
  1808.  
  1809. FUNCTION IsUnique
  1810. *-------------------------------------------------------------------------------
  1811. *-- Programmer..: Clinton L. Warren (VBCES)
  1812. *-- Date........: 04/28/1992
  1813. *-- Notes.......: Checks to see if an index key already exists in the current
  1814. *--               selected database. This function was inspired by Tom
  1815. *--               Woodward's Chk4Dup UDF.
  1816. *-- Written for.: dBASE IV, 1.1
  1817. *-- Rev. History: May 15, 1991 Version 1.1  Added check for zero record database
  1818. *--               May  7, 1991 Version 1.0  Initial 'release'.
  1819. *--               04/28/1992 -- modified for dBASE IV, 1.5 due to 'new'
  1820. *--               behavior (see READ.ME that comes with 1.5). Should function
  1821. *--               fine with 1.1 and 1.0. This change from David Love (DAVIDLOVE).
  1822. *--               NOTE: NEW PARAMETER
  1823. *-- Calls.......: None
  1824. *-- Called by...: Any
  1825. *-- Usage.......: IsUnique(<xValue>,"<cOrder>","<cField>")
  1826. *-- Example.....: @5,5 SAY "SSN: " GET SSN PICTURE "999-99-9999";
  1827. *--                  valid required IsUnique(SSN, "SSN", "SSN");
  1828. *--                  message "Enter a new SSN";
  1829. *--                  error chr(7)+"SSN must be unique!"
  1830. *-- Returns.....: .T./.F.
  1831. *-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness
  1832. *--               cOrder = MDX Tag used to order the database. Must be set for
  1833. *--                        field being checked.
  1834. *--               cField = field name for 'get'.
  1835. *-------------------------------------------------------------------------------
  1836.     
  1837.     parameters xValue, cOrder, cField
  1838.     private nRecNo, nRecCnt, cSetNear, cSetDel, lIsDeleted, cSetOrder
  1839.     private lIsUnique
  1840.     
  1841.     nRecNo = recno()           && store current record number
  1842.     nRecCnt = reccount()       && count records in database
  1843.     
  1844.     if nRecCnt = 0             && empty database, cValue MUST be unique
  1845.        return .t.
  1846.     endif
  1847.     
  1848.     cSetNear = set('NEAR')     && store status of NEAR flag
  1849.     set near off               && set it off
  1850.     cSetDel = set('DELETE')    && store status of DELETE
  1851.     set delete on              && Delete must be ON for this to work
  1852.     lIsDeleted = deleted()     && is current record deleted?
  1853.     delete                     && set delete flag for current record
  1854.     cSetOrder = order()        && store current MDX tag
  1855.     set order to (cOrder)      && set tag to that sent to function
  1856.     
  1857.     if seek(xValue)            && does it exist already?
  1858.        lIsUnique = .f.         &&   if so, it's not unique
  1859.     else                       && otherwise,
  1860.        lIsUnique = .t.         &&   it is.
  1861.     endif
  1862.    
  1863.    set order to (cSetOrder)   && restore changed settings to original settings
  1864.    set delete &cSetDel
  1865.    set near &cSetNear
  1866.    
  1867.    if nRecNo > nRecCnt        && if called during an append
  1868.       go bottom               && goto the bottom of the database,
  1869.       skip 1                  &&   plus one record (the new one)
  1870.       if lIsUnique            && this is the new part ...
  1871.          replace &cField with xValue
  1872.       endif
  1873.    else
  1874.       go nRecNo               && otherwise, goto the current record number
  1875.    endif
  1876.  
  1877.    if .not. lIsDeleted        && was record 'deleted' before?
  1878.       recall                  && if not, undelete it ... (turn flag off)
  1879.    endif 
  1880.  
  1881. RETURN (lIsUnique)
  1882. *-- EoF: IsUnique()
  1883.  
  1884. *===============================================================================
  1885. * MISC ROUTINES -- Ones that don't fit into other categories, quite ... but
  1886. * are none-the-less very useful ... many of these routines have been placed
  1887. * in the library file:  MISC.PRG.
  1888. *===============================================================================
  1889.  
  1890. PROCEDURE SetPrint
  1891. *-------------------------------------------------------------------------------
  1892. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1893. *-- Date........: 05/24/1991
  1894. *-- Notes.......: Used to set the the appropriate default settings. 
  1895. *--               (Can be modified easily for other printers ...)
  1896. *--               If you want "letter quality" print on some printers,
  1897. *--               you can take the * out from the one line below. Note
  1898. *--               that some printer drivers don't have a "letter quality" mode,
  1899. *--               and dBASE will spit out an error message if you try to
  1900. *--               force it (by using _pquality). I use this routine for
  1901. *--               various systems, and only use _pquality for my dot matrix
  1902. *--               at home. Change the printer driver below to the one you
  1903. *--               are using. The _pdriver line only REALLY needs to be 
  1904. *--               in use on a LAN, where who knows what settings may have been
  1905. *--               dumped into the printer in between the time you loaded dBASE
  1906. *--               (and the printer driver) and the time you really want to
  1907. *--               print?
  1908. *-- Written for.: dBASE IV, 1.1
  1909. *-- Rev. History: None
  1910. *-- Calls.......: None
  1911. *-- Called by...: Any
  1912. *-- Usage.......: do setprint
  1913. *-- Example.....: do setprint
  1914. *-- Returns.....: None
  1915. *-- Parameters..: None
  1916. *-------------------------------------------------------------------------------
  1917.     *_pdriver  = "HPLAS2I"  && printer driver
  1918.     _ppitch   = "PICA"     && printer pitch (10 CPI)    
  1919.     _box      = .t.          && make sure we can print boxes/line draw
  1920.     _ploffset = 0          && page offset (left side) to 0
  1921.     _lmargin  = 0          && left margin (also set to 0)
  1922.     _rmargin  = 80         && right margin set to 80
  1923.     _plength  = 66         && page length 
  1924.     _peject   = "NONE"     && don't send extra blank pages . . .
  1925.     * _pquality = .t.        && set print quality to high -- not available
  1926.                              && for some printers (i.e., LaserJets)
  1927.     
  1928. RETURN   
  1929. *-- EoP: SetPrint
  1930.  
  1931. FUNCTION DosRun
  1932. *-------------------------------------------------------------------------------
  1933. *-- Programmer..: Michael P. Dean (Ashton-Tate)
  1934. *-- Date........: 05/01/1992
  1935. *-- Notes.......: A routine to run a DOS program, checks to see if a
  1936. *--               window is active -- if so, it avoids the inevitable
  1937. *--               "Press any key to continue" and the subsequent messing
  1938. *--               up of the screen display.
  1939. *-- Written for.: dBASE IV, 1.1
  1940. *-- Rev. History: Pulled from A-T BBS 
  1941. *--               05/13/1991 - modified by Ken Mayer to use the DBASE
  1942. *--               RUN() function, rather than the ! or RUN commands.
  1943. *--               (suggested by Clinton L. Warren (VBCES).)
  1944. *--               Minor additions for screens from "Bosephus" on ATBBS 10/31/91
  1945. *--               12/14/1991 - modified by Jim Magnant (TXAGGIE) to deactivate
  1946. *--               and reactivate up to 10 windows ...
  1947. *--               04/21/1992 -- Modified for dBASE IV, 1.5 to use memory 
  1948. *--               handling parameters (.t.,<command>,.t.) of RUN() function.
  1949. *--               05/01/1992 -- Modified to allow use with EITHER 1.1 or 1.5.
  1950. *--                By calling VERSION() without a parm, the version of dBASE
  1951. *--                or RUNTIME is the last three characters on the right. 
  1952. *--                Taking the VAL() of that, we can ask if the version is => 1.5
  1953. *--                and process from there.
  1954. *-- Calls.......: None
  1955. *-- Called by...: Any
  1956. *-- Usage.......: DosRun(<cCmd>)
  1957. *-- Example.....: ndummy = dosrun("DIR /W /P")
  1958. *--                 * or
  1959. *--               ndummy = dosrun(memvar)  && where memvar contains dos
  1960. *--                                        && command and parameters ...
  1961. *-- Returns.....: Nul
  1962. *-- Parameters..: cCmd = Command (and parameters) to be executed
  1963. *-------------------------------------------------------------------------------
  1964.  
  1965.     parameter cCmd
  1966.     private aWindow, n, nRun
  1967.     
  1968.     save screen to sDOS          && save screen ...
  1969.     n = 0                        && set to 0 in case there are NO Windows active
  1970.     declare aWindow[10]
  1971.     aWindow[1] = window()               && grab window name of current window
  1972.     if len(trim(aWindow[1])) > 0        && if there's a window, deactivate
  1973.         n = 1 
  1974.         do while len(trim(aWindow[n])) > 0  && if there are more windows ...
  1975.             deactivate window &aWindow[n]    && deactivate them, too ...
  1976.             n = n + 1
  1977.             aWindow[n] = window()
  1978.         enddo
  1979.     endif
  1980.     set console off                     && don't display to screen
  1981.     if val(right(version(),3)) => 1.5   && check version number. If > 1.5
  1982.         nRun = run(.t.,"&cCmd",.t.)      &&  use complete swapping of dBASE, etc.
  1983.     else                                && else it's 1.1 or 1.0
  1984.         nRun = run("&cCmd")              &&  use older version of RUN() function
  1985.     endif
  1986.     set console on                      && ok, display to screen
  1987.     n = n - 1                           && compensate for final n=n+1 in prev.
  1988.     if len(trim(aWindow[1])) > 1        && if there's a window, reactivate
  1989.        do while n > 0                   && all but last window
  1990.             activate window &aWindow[n]   && activate
  1991.             n = n - 1                     && decrement stack
  1992.         enddo
  1993.         activate window &aWindow[1]      && activate final window ...
  1994.     endif
  1995.     restore screen from sDOS
  1996.     release screen sDOS
  1997.     
  1998. RETURN ""
  1999. *-- EoF: DosRun()
  2000.  
  2001. FUNCTION ScrnRpt
  2002. *-------------------------------------------------------------------------------
  2003. *-- Programmer...: Bryan Flynn (AT/BOR-BBS)
  2004. *-- Date.........: 10/31/91
  2005. *-- Notes........: Used to display a dBASE Report on screen, allowing pauses
  2006. *--                when the screen is full.
  2007. *-- Written for..: dBASE IV, 1.1
  2008. *-- Rev. History.: Changed by a lot of people to current version.
  2009. *-- Calls........: None
  2010. *-- Called by....: Any
  2011. *-- Usage........: ?ScrnRpt("<cRpt cArg>")
  2012. *-- Example......: ?ScrnRpt("FT_REP1 FOR PROB='HPEQUIP'")
  2013. *-- Returns......: ""  (Nul)
  2014. *-- Parameters...: cRpt  = Name of report with any arguments for command line
  2015. *-------------------------------------------------------------------------------
  2016.  
  2017.     Parameter cRpt
  2018.     private lPWait, nPLength, cEscape
  2019.     
  2020.     *-- save system variables
  2021.    lPWait   = _pwait
  2022.    nPLength = _plength
  2023.     cEscape  = SET("ESCAPE")
  2024.     *-- set new variables
  2025.    _pwait   = .t.
  2026.     _plength = iif("43" $ SET("DISPLAY"),40,25)  && if EGA43, set to 40, else 25
  2027.    set escape on
  2028.     
  2029.     *-- store current screen
  2030.    save screen to sTemp
  2031.    clear
  2032.  
  2033.     *-- set printer to nowhere and generate report
  2034.    set printer to nul
  2035.    report form &cRpt noeject to print
  2036.  
  2037.     *-- set things back to normal
  2038.    set escape &cEscape
  2039.    set printer to LPT1
  2040.    wait
  2041.    clear
  2042.    restore screen from sTemp
  2043.    release screen sTemp
  2044.    _pwait   = lPWait
  2045.    _plength = nPLength
  2046.  
  2047. RETURN ""
  2048. *-- EoF: ScrnRpt()
  2049.  
  2050. FUNCTION IsMouse
  2051. *-------------------------------------------------------------------------------
  2052. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2053. *-- Date........: 06/18/1992
  2054. *-- Notes.......: This is used to determine the presence of a mouse driver.
  2055. *--               Returns a .t. if a mouse driver is detected, a .f. otherwise.
  2056. *--               This routine will turn the mouse off, automatically. This
  2057. *--               can be used to detect a mouse, and turn it off, as well
  2058. *--               as to set a memvar to determine the current mouse state.
  2059. *--               For example, after running this routine, the mouse will be
  2060. *--               off (if there's a driver).
  2061. *--               ******************************
  2062. *--               **** REQUIRES JPMOUSE.BIN ****
  2063. *--               ******************************
  2064. *-- Written for.: dBASE IV, 1.5
  2065. *-- Rev. History: None
  2066. *-- Calls.......: None
  2067. *-- Called by...: Any
  2068. *-- Usage.......: IsMouse()
  2069. *-- Example.....: ?IsMouse()
  2070. *-- Returns.....: Logical
  2071. *-- Parameters..: None
  2072. *-------------------------------------------------------------------------------
  2073.  
  2074.     private cRetVal, lIsMouse, X
  2075.     
  2076.     Load JPMOUSE.BIN
  2077.     cRetVal = call("JPMOUSE","?")
  2078.     lIsMouse = iif(cRetVal="T",.t.,.f.)
  2079.     if lIsMouse
  2080.         x = call("JPMOUSE","H")
  2081.     endif
  2082.     release module JPMOUSE
  2083.  
  2084. RETURN lIsMouse
  2085. *-- EoF: IsMouse()
  2086.  
  2087. PROCEDURE SetMouse
  2088. *-------------------------------------------------------------------------------
  2089. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2090. *-- Date........: 06/18/1992
  2091. *-- Notes.......: This is used to determine the presence of a mouse driver,
  2092. *--               and/or turn the mouse cursor off in dBASE IV, 1.5
  2093. *--               ******************************
  2094. *--               **** Requires JPMOUSE.BIN ****
  2095. *--               ******************************
  2096. *-- Written for.: dBASE IV, 1.5
  2097. *-- Rev. History: None
  2098. *-- Calls.......: None
  2099. *-- Called by...: Any
  2100. *-- Usage.......: Do SetMouse with <c_Mouse>
  2101. *-- Example.....: PUBLIC c_Mouse
  2102. *--               x=ismouse()  && function in MISC.PRG
  2103. *--               store "OFF" to c_Mouse  && after calling IsMouse() it's 'Off'
  2104. *--               ON KEY LABEL Alt-M DO SetMouse
  2105. *-- Returns.....: .T.
  2106. *-- Parameters..: c_Mouse = A GLOBAL memory variable -- this can/will be changed
  2107. *--                         by this procedure to the opposite scenario when the
  2108. *--                         routine is called. The concept here is to switch
  2109. *--                         the mouse on and/or off if there's a mouse driver.
  2110. *--                This memvar should be set to the current status of the mouse-
  2111. *--                if on, it should hold "ON" in it ...
  2112. *-------------------------------------------------------------------------------
  2113.  
  2114.     private X
  2115.     
  2116.     if type("C_MOUSE") # "C"         && if c_Mouse has not been defined as
  2117.         return                        &&   a character field, return
  2118.     endif
  2119.     
  2120.     load JPMOUSE.BIN                && load the module
  2121.     
  2122.     *-- if the mouse is off, we're going to set it on ("S"), if on, we're
  2123.     *-- going to set it off "H")
  2124.     cSetMouse = iif(upper(c_Mouse) = "OFF","S","H") 
  2125.     x=call("JPMOUSE",cSetMouse)      
  2126.     
  2127.     release module JPMOUSE           && remove from memory
  2128.     
  2129.     *-- if c_Mouse was 'off' we are setting it 'on', and vice versa
  2130.     c_Mouse = iif(upper(c_Mouse) = "OFF","ON","OFF") && change state of c_Mouse
  2131.  
  2132. RETURN
  2133. *-- EoP: SetMouse
  2134.  
  2135. FUNCTION SwitchLib
  2136. *-------------------------------------------------------------------------------
  2137. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2138. *-- Date........: 05/01/1992
  2139. *-- Notes.......: Used with dBASE IV, 1.5 to switch LIBRARY files. It's designed
  2140. *--               as a quick toggle between libraries. See example below.
  2141. *-- Written for.: dBASE IV, 1.5
  2142. *-- Rev. History: None
  2143. *-- Calls.......: None
  2144. *-- Called by...: Any
  2145. *-- Usage.......: SwitchLib(<cNewLib>)
  2146. *-- Example.....: cOldLib = SwitchLib("FILES")
  2147. *--               *-- execute function/procedure needed
  2148. *--               cOldLib = SwitchLib("&cOldLib")
  2149. *-- Returns.....: Old Library setting
  2150. *-- Parameters..: cNewLib = Library file you wish to change to. If the file
  2151. *--                         extension is not '.PRG', you should add the file
  2152. *--                         extension to the description (I.e, "FILES.LIB")
  2153. *-------------------------------------------------------------------------------
  2154.     
  2155.     parameters cNewLib
  2156.     private cCurLib
  2157.     
  2158.     cCurLib = set("LIBRARY")
  2159.     set library to &cNewLib.
  2160.     
  2161. RETURN cCurLib
  2162. *-- EoF: SwitchLib()
  2163.  
  2164. FUNCTION VerLevel
  2165. *-------------------------------------------------------------------------------
  2166. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  2167. *-- Date........: 06-24-1992
  2168. *-- Notes.......: Returns the numeric version number of the current version
  2169. *--               of dBASE or RUNTIME. Useful in version specific routines.
  2170. *-- Written for.: dBASE IV, 1.5
  2171. *-- Rev. History: None
  2172. *-- Calls.......: None
  2173. *-- Called by...: Any
  2174. *-- Usage.......: VerLevel()
  2175. *-- Example.....: if VerLevel() >= 1.5
  2176. *-- Returns.....: a numeric equivalent of Version()
  2177. *-- Parameters..: None
  2178. *-------------------------------------------------------------------------------
  2179.  
  2180.     private cVersion, nPos
  2181.     cVersion = version()
  2182.     nPos = 1
  2183.     do while left(right(cVersion,nPos),1) # " "
  2184.         nPos = nPos + 1
  2185.     enddo
  2186.  
  2187. RETURN val(right(cVersion,nPos+1))
  2188. *-- Eof() VerLevel
  2189.  
  2190. *===============================================================================
  2191. *-- End of Procedure File -- PROC.PRG
  2192. *===============================================================================
  2193.